Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume24 / gnucalc / part29 < prev next >

Wrap

Text File | 1991-10-31 | 55.2 KB | 1,764 lines

Newsgroups: comp.sources.misc From: daveg@synaptics.com (David Gillespie) Subject: v24i077: gnucalc - GNU Emacs Calculator, v2.00, Part29/56 Message-ID: <1991Oct31.214331.2109@sparky.imd.sterling.com> X-Md4-Signature: d6ea4cba7bb16d7278d5304d42f92a3c Date: Thu, 31 Oct 1991 21:43:31 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: daveg@synaptics.com (David Gillespie) Posting-number: Volume 24, Issue 77 Archive-name: gnucalc/part29 Environment: Emacs Supersedes: gmcalc: Volume 13, Issue 27-45 ---- Cut Here and unpack ---- #!/bin/sh # do not concatenate these parts, unpack them in order with /bin/sh # file calc-units.el continued # if test ! -r _shar_seq_.tmp; then echo 'Please unpack part 1 first!' exit 1 fi (read Scheck if test "$Scheck" != 29; then echo Please unpack part "$Scheck" next! exit 1 else exit 0 fi ) < _shar_seq_.tmp || exit 1 if test ! -f _shar_wnt_.tmp; then echo 'x - still skipping calc-units.el' else echo 'x - continuing file calc-units.el' sed 's/^X//' << 'SHAR_EOF' >> 'calc-units.el' && X (setq uoldname (concat "1" uoldname))) X (math-read-expr uoldname)))))) X (if (eq (car-safe uold) 'error) X (error "Bad format in units expression: %s" (nth 1 uold))) X (setq expr (math-mul expr uold)))) X (or new-units X (setq new-units (read-string (if uoldname X (concat "Old units: " X uoldname X ", new units: ") X "New units: ")))) X (if (string-match "\\` */" new-units) X (setq new-units (concat "1" new-units))) X (setq units (math-read-expr new-units)) X (if (eq (car-safe units) 'error) X (error "Bad format in units expression: %s" (nth 2 units))) X (let ((unew (math-units-in-expr-p units t)) X (std (and (eq (car-safe units) 'var) X (assq (nth 1 units) math-standard-units-systems)))) X (if std X (calc-enter-result 1 "cvun" (math-simplify-units X (math-to-standard-units expr X (nth 1 std)))) X (or unew X (error "No units specified")) X (calc-enter-result 1 "cvun" X (math-convert-units X expr units X (and uoldname (not (equal uoldname "1"))))))))) ) X (defun calc-autorange-units (arg) X (interactive "P") X (calc-wrapper X (calc-change-mode 'calc-autorange-units arg nil t) X (message (if calc-autorange-units X "Adjusting target unit prefix automatically." X "Using target units exactly."))) ) X (defun calc-convert-temperature (&optional old-units new-units) X (interactive) X (calc-slow-wrapper X (let ((expr (calc-top-n 1)) X (uold nil) X (uoldname nil) X unew) X (setq uold (or old-units X (let ((units (math-single-units-in-expr-p expr))) X (if units X (if (consp units) X (list 'var (car units) X (intern (concat "var-" X (symbol-name X (car units))))) X (error "Not a pure temperature expression")) X (math-read-expr X (setq uoldname (read-string X "Old temperature units: "))))))) X (if (eq (car-safe uold) 'error) X (error "Bad format in units expression: %s" (nth 2 uold))) X (or (math-units-in-expr-p expr nil) X (setq expr (math-mul expr uold))) X (setq unew (or new-units X (math-read-expr X (read-string (if uoldname X (concat "Old temperature units: " X uoldname X ", new units: ") X "New temperature units: "))))) X (if (eq (car-safe unew) 'error) X (error "Bad format in units expression: %s" (nth 2 unew))) X (calc-enter-result 1 "cvtm" (math-simplify-units X (math-convert-temperature expr uold unew X uoldname))))) ) X (defun calc-remove-units () X (interactive) X (calc-slow-wrapper X (calc-enter-result 1 "rmun" (math-simplify-units X (math-remove-units (calc-top-n 1))))) ) X (defun calc-extract-units () X (interactive) X (calc-slow-wrapper X (calc-enter-result 1 "rmun" (math-simplify-units X (math-extract-units (calc-top-n 1))))) ) X (defun calc-explain-units () X (interactive) X (calc-wrapper X (let ((num-units nil) X (den-units nil)) X (calc-explain-units-rec (calc-top-n 1) 1) X (and den-units (string-match "^[^(].* .*[^)]$" den-units) X (setq den-units (concat "(" den-units ")"))) X (if num-units X (if den-units X (message "%s per %s" num-units den-units) X (message "%s" num-units)) X (if den-units X (message "1 per %s" den-units) X (message "No units in expression"))))) ) X (defun calc-explain-units-rec (expr pow) X (let ((u (math-check-unit-name expr)) X pos) X (if (and u (not (math-zerop pow))) X (let ((name (or (nth 2 u) (symbol-name (car u))))) X (if (eq (aref name 0) ?\*) X (setq name (substring name 1))) X (if (string-match "[^a-zA-Z0-9']" name) X (if (string-match "^[a-zA-Z0-9' ()]*$" name) X (while (setq pos (string-match "[ ()]" name)) X (setq name (concat (substring name 0 pos) X (if (eq (aref name pos) 32) "-" "") X (substring name (1+ pos))))) X (setq name (concat "(" name ")")))) X (or (eq (nth 1 expr) (car u)) X (setq name (concat (nth 2 (assq (aref (symbol-name X (nth 1 expr)) 0) X math-unit-prefixes)) X (if (and (string-match "[^a-zA-Z0-9']" name) X (not (memq (car u) '(mHg gf)))) X (concat "-" name) X (downcase name))))) X (cond ((or (math-equal-int pow 1) X (math-equal-int pow -1))) X ((or (math-equal-int pow 2) X (math-equal-int pow -2)) X (if (equal (nth 4 u) '((m . 1))) X (setq name (concat "Square-" name)) X (setq name (concat name "-squared")))) X ((or (math-equal-int pow 3) X (math-equal-int pow -3)) X (if (equal (nth 4 u) '((m . 1))) X (setq name (concat "Cubic-" name)) X (setq name (concat name "-cubed")))) X (t X (setq name (concat name "^" X (math-format-number (math-abs pow)))))) X (if (math-posp pow) X (setq num-units (if num-units X (concat num-units " " name) X name)) X (setq den-units (if den-units X (concat den-units " " name) X name)))) X (cond ((eq (car-safe expr) '*) X (calc-explain-units-rec (nth 1 expr) pow) X (calc-explain-units-rec (nth 2 expr) pow)) X ((eq (car-safe expr) '/) X (calc-explain-units-rec (nth 1 expr) pow) X (calc-explain-units-rec (nth 2 expr) (- pow))) X ((memq (car-safe expr) '(neg + -)) X (calc-explain-units-rec (nth 1 expr) pow)) X ((and (eq (car-safe expr) '^) X (math-realp (nth 2 expr))) X (calc-explain-units-rec (nth 1 expr) X (math-mul pow (nth 2 expr))))))) ) X (defun calc-simplify-units () X (interactive) X (calc-slow-wrapper X (calc-with-default-simplification X (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1))))) ) X (defun calc-view-units-table (n) X (interactive "P") X (and n (setq math-units-table-buffer-valid nil)) X (let ((win (get-buffer-window "*Units Table*"))) X (if (and win X math-units-table X math-units-table-buffer-valid) X (progn X (bury-buffer (window-buffer win)) X (let ((curwin (selected-window))) X (select-window win) X (switch-to-buffer nil) X (select-window curwin))) X (math-build-units-table-buffer nil))) ) X (defun calc-enter-units-table (n) X (interactive "P") X (and n (setq math-units-table-buffer-valid nil)) X (math-build-units-table-buffer t) X (message (substitute-command-keys "Type \\[calc] to return to the Calculator.")) ) X (defun calc-define-unit (uname desc) X (interactive "SDefine unit name: \nsDescription: ") X (calc-wrapper X (let ((form (calc-top-n 1)) X (unit (assq uname math-additional-units))) X (or unit X (setq math-additional-units X (cons (setq unit (list uname nil nil)) X math-additional-units) X math-units-table nil)) X (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var) X (eq (nth 1 form) uname))) X (not (math-equal-int form 1)) X (math-format-flat-expr form 0))) X (setcar (cdr (cdr unit)) (and (not (equal desc "")) X desc)))) X (calc-invalidate-units-table) ) X (defun calc-undefine-unit (uname) X (interactive "SUndefine unit name: ") X (calc-wrapper X (let ((unit (assq uname math-additional-units))) X (or unit X (if (assq uname math-standard-units) X (error "\"%s\" is a predefined unit name" uname) X (error "Unit name \"%s\" not found" uname))) X (setq math-additional-units (delq unit math-additional-units) X math-units-table nil))) X (calc-invalidate-units-table) ) X (defun calc-invalidate-units-table () X (setq math-units-table nil) X (let ((buf (get-buffer "*Units Table*"))) X (and buf X (save-excursion X (set-buffer buf) X (save-excursion X (goto-char (point-min)) X (if (looking-at "Calculator Units Table") X (let ((buffer-read-only nil)) X (insert "(Obsolete) "))))))) ) X (defun calc-get-unit-definition (uname) X (interactive "SGet definition for unit: ") X (calc-wrapper X (math-build-units-table) X (let ((unit (assq uname math-units-table))) X (or unit X (error "Unit name \"%s\" not found" uname)) X (let ((msg (nth 2 unit))) X (if (stringp msg) X (if (string-match "^\\*" msg) X (setq msg (substring msg 1))) X (setq msg (symbol-name uname))) X (if (nth 1 unit) X (progn X (calc-enter-result 0 "ugdf" (nth 1 unit)) X (message "Derived unit: %s" msg)) X (calc-enter-result 0 "ugdf" (list 'var uname X (intern X (concat "var-" X (symbol-name uname))))) X (message "Base unit: %s" msg))))) ) X (defun calc-permanent-units () X (interactive) X (calc-wrapper X (let (pos) X (set-buffer (find-file-noselect (substitute-in-file-name X calc-settings-file))) X (goto-char (point-min)) X (if (and (search-forward ";;; Custom units stored by Calc" nil t) X (progn X (beginning-of-line) X (setq pos (point)) X (search-forward "\n;;; End of custom units" nil t))) X (progn X (beginning-of-line) X (forward-line 1) X (delete-region pos (point))) X (goto-char (point-max)) X (insert "\n\n") X (forward-char -1)) X (insert ";;; Custom units stored by Calc on " (current-time-string) "\n") X (if math-additional-units X (progn X (insert "(setq math-additional-units '(\n") X (let ((list math-additional-units)) X (while list X (insert " (" (symbol-name (car (car list))) " " X (if (nth 1 (car list)) X (if (stringp (nth 1 (car list))) X (prin1-to-string (nth 1 (car list))) X (prin1-to-string (math-format-flat-expr X (nth 1 (car list)) 0))) X "nil") X " " X (prin1-to-string (nth 2 (car list))) X ")\n") X (setq list (cdr list)))) X (insert "))\n")) X (insert ";;; (no custom units defined)\n")) X (insert ";;; End of custom units\n") X (save-buffer))) ) X X X X X ;;; Units operations. X ;;; Units table last updated 9-Jan-91 by Ulrich Mueller (ulm@vsnhd1.cern.ch) ;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov) X (defvar math-standard-units X '( ;; Length X ( m nil "*Meter" ) X ( in "2.54 cm" "Inch" ) X ( ft "12 in" "Foot" ) X ( yd "3 ft" "Yard" ) X ( mi "5280 ft" "Mile" ) X ( au "1.495979e11 m" "Astronomical Unit" ) X ( lyr "9460536207068016 m" "Light Year" ) X ( pc "206264.80625 au" "Parsec" ) X ( nmi "1852 m" "Nautical Mile" ) X ( fath "6 ft" "Fathom" ) X ( u "1 um" "Micron" ) X ( mil "in/1000" "Mil" ) X ( point "in/72" "Point (1/72 inch)" ) X ( tpt "in/72.27" "Point (TeX conventions)" ) X ( Ang "1e-10 m" "Angstrom" ) X ( mfi "mi+ft+in" "Miles + feet + inches" ) X X ;; Area X ( hect "10000 m^2" "*Hectare" ) X ( acre "mi^2 / 640" "Acre" ) X ( b "1e-28 m^2" "Barn" ) X X ;; Volume X ( l "1e-3 m^3" "*Liter" ) X ( L "1e-3 m^3" "Liter" ) X ( gal "4 qt" "US Gallon" ) X ( qt "2 pt" "Quart" ) X ( pt "2 cup" "Pint" ) X ( cup "8 ozfl" "Cup" ) X ( ozfl "2 tbsp" "Fluid Ounce" ) X ( floz "2 tbsp" "Fluid Ounce" ) X ( tbsp "3 tsp" "Tablespoon" ) X ( tsp "4.92892159375 ml" "Teaspoon" ) X ( vol "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" ) X ( galC "4.54609 l" "Canadian Gallon" ) X ( galUK "4.546092 l" "UK Gallon" ) X X ;; Time X ( s nil "*Second" ) X ( sec "s" "Second" ) X ( min "60 s" "Minute" ) X ( hr "60 min" "Hour" ) X ( day "24 hr" "Day" ) X ( wk "7 day" "Week" ) X ( hms "wk+day+hr+min+s" "Hours, minutes, seconds" ) X ( yr "365.25 day" "Year" ) X ( Hz "1/s" "Hertz" ) X X ;; Speed X ( mph "mi/hr" "*Miles per hour" ) X ( kph "km/hr" "Kilometers per hour" ) X ( knot "nmi/hr" "Knot" ) X ( c "2.99792458e8 m/s" "Speed of light" ) X X ;; Acceleration X ( ga "9.80665 m/s^2" "*\"g\" acceleration" ) X X ;; Mass X ( g nil "*Gram" ) X ( lb "16 oz" "Pound (mass)" ) X ( oz "28.349523125 g" "Ounce (mass)" ) X ( ton "2000 lb" "Ton" ) X ( tpo "ton+lb+oz" "Tons + pounds + ounces (mass)" ) X ( t "1000 kg" "Metric ton" ) X ( tonUK "1016.0469088 kg" "UK ton" ) X ( lbt "12 ozt" "Troy pound" ) X ( ozt "31.103475 g" "Troy ounce" ) X ( ct ".2 g" "Carat" ) X ( amu "1.6605402e-24 g" "Unified atomic mass" ) X X ;; Force X ( N "m kg/s^2" "*Newton" ) X ( dyn "1e-5 N" "Dyne" ) X ( gf "ga g" "Gram (force)" ) X ( lbf "4.44822161526 N" "Pound (force)" ) X ( kip "1000 lbf" "Kilopound (force)" ) X ( pdl "0.138255 N" "Poundal" ) X X ;; Energy X ( J "N m" "*Joule" ) X ( erg "1e-7 J" "Erg" ) X ( cal "4.1868 J" "International Table Calorie" ) X ( Btu "1055.05585262 J" "International Table Btu" ) X ( eV "ech V" "Electron volt" ) X ( ev "eV" "Electron volt" ) X ( therm "105506000 J" "EEC therm" ) X ( invcm "h c/cm" "Energy in inverse centimeters" ) X ( Kayser "invcm" "Kayser (inverse centimeter energy)" ) X ( men "100/invcm" "Inverse energy in meters" ) X ( Hzen "h Hz" "Energy in Hertz") X ( Ken "k K" "Energy in Kelvins") X ;; ( invcm "eV / 8065.47835185" "Energy in inverse centimeters" ) X ;; ( Hzen "eV / 2.41796958004e14" "Energy in Hertz") X ;; ( Ken "eV / 11604.7967327" "Energy in Kelvins") X X ;; Power X ( W "J/s" "*Watt" ) X ( hp "745.7 W" "Horsepower" ) X X ;; Temperature X ( K nil "*Degree Kelvin" K ) X ( dK "K" "Degree Kelvin" K ) X ( degK "K" "Degree Kelvin" K ) X ( dC "K" "Degree Celsius" C ) X ( degC "K" "Degree Celsius" C ) X ( dF "(5/9) K" "Degree Fahrenheit" F ) X ( degF "(5/9) K" "Degree Fahrenheit" F ) X X ;; Pressure X ( Pa "N/m^2" "*Pascal" ) X ( bar "1e5 Pa" "Bar" ) X ( atm "101325 Pa" "Standard atmosphere" ) X ( torr "atm/760" "Torr" ) X ( mHg "1000 torr" "Meter of mercury" ) X ( inHg "25.4 mmHg" "Inch of mercury" ) X ( inH2O "248.84 Pa" "Inch of water" ) X ( psi "6894.75729317 Pa" "Pound per square inch" ) X X ;; Viscosity X ( P "0.1 Pa s" "*Poise" ) X ( St "1e-4 m^2/s" "Stokes" ) X X ;; Electromagnetism X ( A nil "*Ampere" ) X ( C "A s" "Coulomb" ) X ( Fdy "ech Nav" "Faraday" ) X ( e "1.60217733e-19 C" "Elementary charge" ) X ( ech "1.60217733e-19 C" "Elementary charge" ) X ( V "W/A" "Volt" ) X ( ohm "V/A" "Ohm" ) X ( mho "A/V" "Mho" ) X ( S "A/V" "Siemens" ) X ( F "C/V" "Farad" ) X ( H "Wb/A" "Henry" ) X ( T "Wb/m^2" "Tesla" ) X ( G "1e-4 T" "Gauss" ) X ( Wb "V s" "Weber" ) X X ;; Luminous intensity X ( cd nil "*Candela" ) X ( sb "1e4 cd/m^2" "Stilb" ) X ( lm "cd sr" "Lumen" ) X ( lx "lm/m^2" "Lux" ) X ( ph "1e4 lx" "Phot" ) X ( fc "10.76 lx" "Footcandle" ) X ( lam "1e4 lm/m^2" "Lambert" ) X ( flam "1.07639104e-3 lam" "Footlambert" ) X X ;; Radioactivity X ( Bq "1/s" "*Becquerel" ) X ( Ci "3.7e10 Bq" "Curie" ) X ( Gy "J/kg" "Gray" ) X ( Sv "Gy" "Sievert" ) X ( R "2.58e-4 C/kg" "Roentgen" ) X ( rd ".01 Gy" "Rad" ) X ( rem "rd" "Rem" ) X X ;; Amount of substance X ( mol nil "*Mole" ) X X ;; Plane angle X ( rad nil "*Radian" ) X ( circ "2 pi rad" "Full circle" ) X ( rev "circ" "Full revolution" ) X ( deg "circ/360" "Degree" ) X ( arcmin "deg/60" "Arc minute" ) X ( arcsec "arcmin/60" "Arc second" ) X ( grad "circ/400" "Grade" ) X ( rpm "rev/min" "Revolutions per minute" ) X X ;; Solid angle X ( sr nil "*Steradian" ) X X ;; Other physical quantities (Physics Letters B239, 1 (1990)) X ( h "6.6260755e-34 J s" "*Planck's constant" ) X ( hbar "h / 2 pi" "Planck's constant" ) X ( mu0 "4 pi 1e-7 H/m" "Permeability of vacuum" ) X ( Grav "6.67259e-11 N m^2/kg^2" "Gravitational constant" ) X ( Nav "6.0221367e23 / mol" "Avagadro's constant" ) X ( me "0.51099906 MeV/c^2" "Electron rest mass" ) X ( mp "1.007276470 amu" "Proton rest mass" ) X ( mn "1.008664904 amu" "Neutron rest mass" ) X ( mu "0.113428913 amu" "Muon rest mass" ) X ( Ryd "1.0973731571e5 invcm" "Rydberg's constant" ) X ( k "1.3806513e-23 J/K" "Boltzmann's constant" ) X ( fsc "1 / 137.0359895" "Fine structure constant" ) X ( muB "5.78838263e-11 MeV/T" "Bohr magneton" ) X ( muN "3.15245166e-14 MeV/T" "Nuclear magneton" ) X ( mue "1.001159652193 muB" "Electron magnetic moment" ) X ( mup "2.792847386 muN" "Proton magnetic moment" ) X ( R0 "Nav k" "Molar gas constant" ) X ( V0 "22.413992 L/mol" "Standard volume of ideal gas" ) )) X X (defvar math-additional-units nil X "*Additional units table for user-defined units. Must be formatted like math-standard-units. If this is changed, be sure to set math-units-table to nil to ensure that the combined units table will be rebuilt.") X (defvar math-unit-prefixes X '( ( ?E (float 1 18) "Exa" ) X ( ?P (float 1 15) "Peta" ) X ( ?T (float 1 12) "Tera" ) X ( ?G (float 1 9) "Giga" ) X ( ?M (float 1 6) "Mega" ) X ( ?k (float 1 3) "Kilo" ) X ( ?K (float 1 3) "Kilo" ) X ( ?h (float 1 2) "Hecto" ) X ( ?H (float 1 2) "Hecto" ) X ( ?D (float 1 1) "Deka" ) X ( 0 (float 1 0) nil ) X ( ?d (float 1 -1) "Deci" ) X ( ?c (float 1 -2) "Centi" ) X ( ?m (float 1 -3) "Milli" ) X ( ?u (float 1 -6) "Micro" ) X ( ?n (float 1 -9) "Nano" ) X ( ?p (float 1 -12) "Pico" ) X ( ?f (float 1 -15) "Femto" ) X ( ?a (float 1 -18) "Atto" ) )) X (defvar math-standard-units-systems X '( ( base nil ) X ( si ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) ) X ( mks ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) ) X ( cgs ( ( m '(* (var cm var-cm) 100 ) ) ) ) )) X (defvar math-units-table nil X "Internal units table derived from math-defined-units. Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") X (defvar math-units-table-buffer-valid nil) X X (defun math-build-units-table () X (or math-units-table X (let* ((combined-units (append math-additional-units X math-standard-units)) X (unit-list (mapcar 'car combined-units)) X tab) X (message "Building units table...") X (setq math-units-table-buffer-valid nil) X (setq tab (mapcar (function X (lambda (x) X (list (car x) X (and (nth 1 x) X (if (stringp (nth 1 x)) X (let ((exp (math-read-plain-expr X (nth 1 x)))) X (if (eq (car-safe exp) 'error) X (error "Format error in definition of %s in units table: %s" X (car x) (nth 2 exp)) X exp)) X (nth 1 x))) X (nth 2 x) X (nth 3 x) X (and (not (nth 1 x)) X (list (cons (car x) 1)))))) X combined-units)) X (let ((math-units-table tab)) X (mapcar 'math-find-base-units tab)) X (message "Building units table...done") X (setq math-units-table tab))) ) X (defun math-find-base-units (entry) X (if (eq (nth 4 entry) 'boom) X (error "Circular definition involving unit %s" (car entry))) X (or (nth 4 entry) X (let (base) X (setcar (nthcdr 4 entry) 'boom) X (math-find-base-units-rec (nth 1 entry) 1) X '(or base X (error "Dimensionless definition for unit %s" (car entry))) X (while (eq (cdr (car base)) 0) X (setq base (cdr base))) X (let ((b base)) X (while (cdr b) X (if (eq (cdr (car (cdr b))) 0) X (setcdr b (cdr (cdr b))) X (setq b (cdr b))))) X (setq base (sort base 'math-compare-unit-names)) X (setcar (nthcdr 4 entry) base) X base)) ) X (defun math-compare-unit-names (a b) X (memq (car b) (cdr (memq (car a) unit-list))) ) X (defun math-find-base-units-rec (expr pow) X (let ((u (math-check-unit-name expr))) X (cond (u X (let ((ulist (math-find-base-units u))) X (while ulist X (let ((p (* (cdr (car ulist)) pow)) X (old (assq (car (car ulist)) base))) X (if old X (setcdr old (+ (cdr old) p)) X (setq base (cons (cons (car (car ulist)) p) base)))) X (setq ulist (cdr ulist))))) X ((math-scalarp expr)) X ((and (eq (car expr) '^) X (integerp (nth 2 expr))) X (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr)))) X ((eq (car expr) '*) X (math-find-base-units-rec (nth 1 expr) pow) X (math-find-base-units-rec (nth 2 expr) pow)) X ((eq (car expr) '/) X (math-find-base-units-rec (nth 1 expr) pow) X (math-find-base-units-rec (nth 2 expr) (- pow))) X ((eq (car expr) 'neg) X (math-find-base-units-rec (nth 1 expr) pow)) X ((eq (car expr) '+) X (math-find-base-units-rec (nth 1 expr) pow)) X ((eq (car expr) 'var) X (or (eq (nth 1 expr) 'pi) X (error "Unknown name %s in defining expression for unit %s" X (nth 1 expr) (car entry)))) X (t (error "Malformed defining expression for unit %s" (car entry))))) ) X X (defun math-units-in-expr-p (expr sub-exprs) X (and (consp expr) X (if (eq (car expr) 'var) X (math-check-unit-name expr) X (and (or sub-exprs X (memq (car expr) '(* / ^))) X (or (math-units-in-expr-p (nth 1 expr) sub-exprs) X (math-units-in-expr-p (nth 2 expr) sub-exprs))))) ) X (defun math-only-units-in-expr-p (expr) X (and (consp expr) X (if (eq (car expr) 'var) X (math-check-unit-name expr) X (if (memq (car expr) '(* /)) X (and (math-only-units-in-expr-p (nth 1 expr)) X (math-only-units-in-expr-p (nth 2 expr))) X (and (eq (car expr) '^) X (and (math-only-units-in-expr-p (nth 1 expr)) X (math-realp (nth 2 expr))))))) ) X (defun math-single-units-in-expr-p (expr) X (cond ((math-scalarp expr) nil) X ((eq (car expr) 'var) X (math-check-unit-name expr)) X ((eq (car expr) '*) X (let ((u1 (math-single-units-in-expr-p (nth 1 expr))) X (u2 (math-single-units-in-expr-p (nth 2 expr)))) X (or (and u1 u2 'wrong) X u1 X u2))) X ((eq (car expr) '/) X (if (math-units-in-expr-p (nth 2 expr)) X 'wrong X (math-single-units-in-expr-p (nth 1 expr)))) X (t 'wrong)) ) X (defun math-check-unit-name (v) X (and (eq (car-safe v) 'var) X (or (assq (nth 1 v) (or math-units-table (math-build-units-table))) X (let ((name (symbol-name (nth 1 v)))) X (and (> (length name) 1) X (assq (aref name 0) math-unit-prefixes) X (or (assq (intern (substring name 1)) math-units-table) X (and (eq (aref name 0) ?M) X (> (length name) 3) X (eq (aref name 1) ?e) X (eq (aref name 2) ?g) X (assq (intern (substring name 3)) X math-units-table))))))) ) X X (defun math-to-standard-units (expr which-standard) X (math-to-standard-rec expr) ) X (defun math-to-standard-rec (expr) X (if (eq (car-safe expr) 'var) X (let ((u (math-check-unit-name expr)) X (base (nth 1 expr))) X (if u X (progn X (if (nth 1 u) X (setq expr (math-to-standard-rec (nth 1 u))) X (let ((st (assq (car u) which-standard))) X (if st X (setq expr (nth 1 st)) X (setq expr (list 'var (car u) X (intern (concat "var-" X (symbol-name X (car u))))))))) X (or (null u) X (eq base (car u)) X (setq expr (list '* X (nth 1 (assq (aref (symbol-name base) 0) X math-unit-prefixes)) X expr))) X expr) X (if (eq base 'pi) X (math-pi) X expr))) X (if (Math-primp expr) X expr X (cons (car expr) X (mapcar 'math-to-standard-rec (cdr expr))))) ) X (defun math-apply-units (expr units ulist &optional pure) X (if ulist X (let ((new 0) X value) X (setq expr (math-simplify-units expr)) X (or (math-numberp expr) X (error "Incompatible units")) X (while (cdr ulist) X (setq value (math-div expr (nth 1 (car ulist))) X value (math-floor (let ((calc-internal-prec X (1- calc-internal-prec))) X (math-normalize value))) X new (math-add new (math-mul value (car (car ulist)))) X expr (math-sub expr (math-mul value (nth 1 (car ulist)))) X ulist (cdr ulist))) X (math-add new (math-mul (math-div expr (nth 1 (car ulist))) X (car (car ulist))))) X (math-simplify-units (if pure X expr X (list '* expr units)))) ) X (defun math-decompose-units (units) X (let ((u (math-check-unit-name units))) X (and u (eq (car-safe (nth 1 u)) '+) X (setq units (nth 1 u)))) X (setq units (calcFunc-expand units)) X (and (eq (car-safe units) '+) X (let ((entry (list units calc-internal-prec calc-prefer-frac))) X (or (equal entry (car math-decompose-units-cache)) X (let ((ulist nil) X (utemp units) X qty unit) X (while (eq (car-safe utemp) '+) X (setq ulist (cons (math-decompose-unit-part (nth 2 utemp)) X ulist) X utemp (nth 1 utemp))) X (setq ulist (cons (math-decompose-unit-part utemp) ulist) X utemp ulist) X (while (setq utemp (cdr utemp)) X (or (equal (nth 2 (car utemp)) (nth 2 (car ulist))) X (error "Inconsistent units in sum"))) X (setq math-decompose-units-cache X (cons entry X (sort ulist X (function X (lambda (x y) X (not (Math-lessp (nth 1 x) X (nth 1 y)))))))))) X (cdr math-decompose-units-cache))) ) (setq math-decompose-units-cache nil) X (defun math-decompose-unit-part (unit) X (cons unit X (math-is-multiple (math-simplify-units (math-to-standard-units X unit nil)) X t)) ) X (defun math-find-compatible-unit (expr unit) X (let ((u (math-check-unit-name unit))) X (if u X (math-find-compatible-unit-rec expr 1))) ) X (defun math-find-compatible-unit-rec (expr pow) X (cond ((eq (car-safe expr) '*) X (or (math-find-compatible-unit-rec (nth 1 expr) pow) X (math-find-compatible-unit-rec (nth 2 expr) pow))) X ((eq (car-safe expr) '/) X (or (math-find-compatible-unit-rec (nth 1 expr) pow) X (math-find-compatible-unit-rec (nth 2 expr) (- pow)))) X ((and (eq (car-safe expr) '^) X (integerp (nth 2 expr))) X (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr)))) X (t X (let ((u2 (math-check-unit-name expr))) X (if (equal (nth 4 u) (nth 4 u2)) X (cons expr pow))))) ) X (defun math-convert-units (expr new-units &optional pure) X (math-with-extra-prec 2 X (let ((compat (and (not pure) (math-find-compatible-unit expr new-units))) X (unit-list nil) X (math-combining-units nil)) X (if compat X (math-simplify-units X (math-mul (math-mul (math-simplify-units X (math-div expr (math-pow (car compat) X (cdr compat)))) X (math-pow new-units (cdr compat))) X (math-simplify-units X (math-to-standard-units X (math-pow (math-div (car compat) new-units) X (cdr compat)) X nil)))) X (if (setq unit-list (math-decompose-units new-units)) X (setq new-units (nth 2 (car unit-list)))) X (if (eq (car-safe expr) '+) X (setq expr (math-simplify-units expr))) X (if (math-units-in-expr-p expr t) X (math-convert-units-rec expr) X (math-apply-units (math-to-standard-units X (list '/ expr new-units) nil) X new-units unit-list pure))))) ) X (defun math-convert-units-rec (expr) X (if (math-units-in-expr-p expr nil) X (math-apply-units (math-to-standard-units (list '/ expr new-units) nil) X new-units unit-list pure) X (if (Math-primp expr) X expr X (cons (car expr) X (mapcar 'math-convert-units-rec (cdr expr))))) ) X (defun math-convert-temperature (expr old new &optional pure) X (let* ((units (math-single-units-in-expr-p expr)) X (uold (if old X (if (or (null units) X (equal (nth 1 old) (car units))) X (math-check-unit-name old) X (error "Inconsistent temperature units")) X units)) X (unew (math-check-unit-name new))) X (or (and (consp unew) (nth 3 unew)) X (error "Not a valid temperature unit")) X (or (and (consp uold) (nth 3 uold)) X (error "Not a pure temperature expression")) X (let ((v (car uold))) X (setq expr (list '/ expr (list 'var v X (intern (concat "var-" X (symbol-name v))))))) X (or (eq (nth 3 uold) (nth 3 unew)) X (cond ((eq (nth 3 uold) 'K) X (setq expr (list '- expr '(float 27315 -2))) X (if (eq (nth 3 unew) 'F) X (setq expr (list '+ (list '* expr '(frac 9 5)) 32)))) X ((eq (nth 3 uold) 'C) X (if (eq (nth 3 unew) 'F) X (setq expr (list '+ (list '* expr '(frac 9 5)) 32)) X (setq expr (list '+ expr '(float 27315 -2))))) X (t X (setq expr (list '* (list '- expr 32) '(frac 5 9))) X (if (eq (nth 3 unew) 'K) X (setq expr (list '+ expr '(float 27315 -2))))))) X (if pure X expr X (list '* expr new))) ) X X X (defun math-simplify-units (a) X (let ((math-simplifying-units t) X (calc-matrix-mode 'scalar)) X (math-simplify a)) ) (fset 'calcFunc-usimplify (symbol-function 'math-simplify-units)) X (math-defsimplify (+ -) X (and math-simplifying-units X (math-units-in-expr-p (nth 1 expr) nil) X (let* ((units (math-extract-units (nth 1 expr))) X (ratio (math-simplify (math-to-standard-units X (list '/ (nth 2 expr) units) nil)))) X (if (math-units-in-expr-p ratio nil) X (progn X (calc-record-why "*Inconsistent units" expr) X expr) X (list '* (math-add (math-remove-units (nth 1 expr)) X (if (eq (car expr) '-) (math-neg ratio) ratio)) X units)))) ) X (math-defsimplify * X (math-simplify-units-prod) ) X (defun math-simplify-units-prod () X (and math-simplifying-units X calc-autorange-units X (Math-realp (nth 1 expr)) X (let* ((num (math-float (nth 1 expr))) X (xpon (calcFunc-xpon num)) X (unitp (cdr (cdr expr))) X (unit (car unitp)) X (pow (if (eq (car expr) '*) 1 -1)) X u) X (and (eq (car-safe unit) '*) X (setq unitp (cdr unit) X unit (car unitp))) X (and (eq (car-safe unit) '^) X (integerp (nth 2 unit)) X (setq pow (* pow (nth 2 unit)) X unitp (cdr unit) X unit (car unitp))) X (and (setq u (math-check-unit-name unit)) X (integerp xpon) X (or (< xpon 0) X (>= xpon (if (eq (car u) 'm) 1 3))) X (let* ((uxpon 0) X (pref (if (< pow 0) X (reverse math-unit-prefixes) X math-unit-prefixes)) X (p pref) X pxpon pname) X (or (eq (car u) (nth 1 unit)) X (setq uxpon (* pow X (nth 2 (nth 1 (assq X (aref (symbol-name X (nth 1 unit)) 0) X math-unit-prefixes)))))) X (setq xpon (+ xpon uxpon)) X (while (and p X (or (memq (car (car p)) '(?d ?D ?h ?H)) X (and (eq (car (car p)) ?c) X (not (eq (car u) 'm))) X (< xpon (setq pxpon (* (nth 2 (nth 1 (car p))) X pow))) X (progn X (setq pname (math-build-var-name X (if (eq (car (car p)) 0) X (car u) X (concat (char-to-string X (car (car p))) X (symbol-name X (car u)))))) X (and (/= (car (car p)) 0) X (assq (nth 1 pname) X math-units-table))))) X (setq p (cdr p))) X (and p X (/= pxpon uxpon) X (or (not (eq p pref)) X (< xpon (+ pxpon (* (math-abs pow) 3)))) X (progn X (setcar (cdr expr) X (let ((calc-prefer-frac nil)) X (calcFunc-scf (nth 1 expr) X (- uxpon pxpon)))) X (setcar unitp pname) X expr)))))) ) X (math-defsimplify / X (and math-simplifying-units X (let ((np (cdr expr)) X n nn) X (setq n (if (eq (car-safe (nth 2 expr)) '*) X (cdr (nth 2 expr)) X (nthcdr 2 expr))) X (if (math-realp (car n)) X (progn X (setcar (cdr expr) (math-mul (nth 1 expr) X (let ((calc-prefer-frac nil)) X (math-div 1 (car n))))) X (setcar n 1))) X (while (eq (car-safe (setq n (car np))) '*) X (math-simplify-units-divisor (cdr n) (cdr (cdr expr))) X (setq np (cdr (cdr n)))) X (math-simplify-units-divisor np (cdr (cdr expr))) X (math-simplify-units-prod) X expr)) ) X (defun math-simplify-units-divisor (np dp) X (let ((n (car np)) X d dd temp) X (while (eq (car-safe (setq d (car dp))) '*) X (if (setq temp (math-simplify-units-quotient n (nth 1 d))) X (progn X (setcar np (setq n temp)) X (setcar (cdr d) 1))) X (setq dp (cdr (cdr d)))) X (if (setq temp (math-simplify-units-quotient n d)) X (progn X (setcar np (setq n temp)) X (setcar dp 1)))) ) X ;; Simplify, e.g., "in / cm" to "2.54" in a units expression. (defun math-simplify-units-quotient (n d) X (let ((un (math-check-unit-name n)) X (ud (math-check-unit-name d))) X (and un ud X (equal (nth 4 un) (nth 4 ud)) X (math-to-standard-units (list '/ n d) nil))) ) X (math-defsimplify ^ X (and math-simplifying-units X (math-realp (nth 2 expr)) X (if (memq (car-safe (nth 1 expr)) '(* /)) X (list (car (nth 1 expr)) X (list '^ (nth 1 (nth 1 expr)) (nth 2 expr)) X (list '^ (nth 2 (nth 1 expr)) (nth 2 expr))) X (math-simplify-units-pow (nth 1 expr) (nth 2 expr)))) ) X (math-defsimplify calcFunc-sqrt X (and math-simplifying-units X (if (memq (car-safe (nth 1 expr)) '(* /)) X (list (car (nth 1 expr)) X (list 'calcFunc-sqrt (nth 1 (nth 1 expr))) X (list 'calcFunc-sqrt (nth 2 (nth 1 expr)))) X (math-simplify-units-pow (nth 1 expr) '(frac 1 2)))) ) X (math-defsimplify (calcFunc-floor X calcFunc-ceil X calcFunc-round X calcFunc-rounde X calcFunc-roundu X calcFunc-trunc X calcFunc-float X calcFunc-frac X calcFunc-abs X calcFunc-clean) X (and math-simplifying-units X (= (length expr) 2) X (if (math-only-units-in-expr-p (nth 1 expr)) X (nth 1 expr) X (if (and (memq (car-safe (nth 1 expr)) '(* /)) X (or (math-only-units-in-expr-p X (nth 1 (nth 1 expr))) X (math-only-units-in-expr-p X (nth 2 (nth 1 expr))))) X (list (car (nth 1 expr)) X (cons (car expr) X (cons (nth 1 (nth 1 expr)) X (cdr (cdr expr)))) X (cons (car expr) X (cons (nth 2 (nth 1 expr)) X (cdr (cdr expr))))))))) X (defun math-simplify-units-pow (a pow) X (if (and (eq (car-safe a) '^) X (math-check-unit-name (nth 1 a)) X (math-realp (nth 2 a))) X (list '^ (nth 1 a) (math-mul pow (nth 2 a))) X (let* ((u (math-check-unit-name a)) X (pf (math-to-simple-fraction pow)) X (d (and (eq (car-safe pf) 'frac) (nth 2 pf)))) X (and u d X (math-units-are-multiple u d) X (list '^ (math-to-standard-units a nil) pow)))) ) X X (defun math-units-are-multiple (u n) X (setq u (nth 4 u)) X (while (and u (= (% (cdr (car u)) n) 0)) X (setq u (cdr u))) X (null u) ) X (math-defsimplify calcFunc-sin X (and math-simplifying-units X (math-units-in-expr-p (nth 1 expr) nil) X (let ((rad (math-simplify-units X (math-evaluate-expr X (math-to-standard-units (nth 1 expr) nil)))) X (calc-angle-mode 'rad)) X (and (eq (car-safe rad) '*) X (math-realp (nth 1 rad)) X (eq (car-safe (nth 2 rad)) 'var) X (eq (nth 1 (nth 2 rad)) 'rad) X (list 'calcFunc-sin (nth 1 rad))))) ) X (math-defsimplify calcFunc-cos X (and math-simplifying-units X (math-units-in-expr-p (nth 1 expr) nil) X (let ((rad (math-simplify-units X (math-evaluate-expr X (math-to-standard-units (nth 1 expr) nil)))) X (calc-angle-mode 'rad)) X (and (eq (car-safe rad) '*) X (math-realp (nth 1 rad)) X (eq (car-safe (nth 2 rad)) 'var) X (eq (nth 1 (nth 2 rad)) 'rad) X (list 'calcFunc-cos (nth 1 rad))))) ) X (math-defsimplify calcFunc-tan X (and math-simplifying-units X (math-units-in-expr-p (nth 1 expr) nil) X (let ((rad (math-simplify-units X (math-evaluate-expr X (math-to-standard-units (nth 1 expr) nil)))) X (calc-angle-mode 'rad)) X (and (eq (car-safe rad) '*) X (math-realp (nth 1 rad)) X (eq (car-safe (nth 2 rad)) 'var) X (eq (nth 1 (nth 2 rad)) 'rad) X (list 'calcFunc-tan (nth 1 rad))))) ) X X (defun math-remove-units (expr) X (if (math-check-unit-name expr) X 1 X (if (Math-primp expr) X expr X (cons (car expr) X (mapcar 'math-remove-units (cdr expr))))) ) X (defun math-extract-units (expr) X (if (memq (car-safe expr) '(* /)) X (cons (car expr) X (mapcar 'math-extract-units (cdr expr))) X (if (math-check-unit-name expr) expr 1)) ) X (defun math-build-units-table-buffer (enter-buffer) X (if (not (and math-units-table math-units-table-buffer-valid X (get-buffer "*Units Table*"))) X (let ((buf (get-buffer-create "*Units Table*")) X (uptr (math-build-units-table)) X (calc-language (if (eq calc-language 'big) nil calc-language)) X (calc-float-format '(float 0)) X (calc-group-digits nil) X (calc-number-radix 10) X (calc-point-char ".") X (std nil) X u name shadowed) X (save-excursion X (message "Formatting units table...") X (set-buffer buf) X (setq buffer-read-only nil) X (erase-buffer) X (insert "Calculator Units Table:\n\n") X (insert "Unit Type Definition Description\n\n") X (while uptr X (setq u (car uptr) X name (nth 2 u)) X (if (eq (car u) 'm) X (setq std t)) X (setq shadowed (and std (assq (car u) math-additional-units))) X (if (and name X (> (length name) 1) X (eq (aref name 0) ?\*)) X (progn X (or (eq uptr math-units-table) X (insert "\n")) X (setq name (substring name 1)))) X (insert " ") X (and shadowed (insert "(")) X (insert (symbol-name (car u))) X (and shadowed (insert ")")) X (if (nth 3 u) X (progn X (indent-to 10) X (insert (symbol-name (nth 3 u)))) X (or std X (progn X (indent-to 10) X (insert "U")))) X (indent-to 14) X (and shadowed (insert "(")) X (if (nth 1 u) X (insert (math-format-value (nth 1 u) 80)) X (insert (symbol-name (car u)))) X (and shadowed (insert ")")) X (indent-to 41) X (insert " ") X (if name X (insert name)) X (if shadowed X (insert " (redefined above)") X (or (nth 1 u) X (insert " (base unit)"))) X (insert "\n") X (setq uptr (cdr uptr))) X (insert "\n\nUnit Prefix Table:\n\n") X (setq uptr math-unit-prefixes) X (while uptr X (setq u (car uptr)) X (insert " " (char-to-string (car u))) X (if (equal (nth 1 u) (nth 1 (nth 1 uptr))) X (insert " " (char-to-string (car (car (setq uptr (cdr uptr))))) X " ") X (insert " ")) X (insert "10^" (int-to-string (nth 2 (nth 1 u)))) X (indent-to 15) X (insert " " (nth 2 u) "\n") X (while (eq (car (car (setq uptr (cdr uptr)))) 0))) X (insert "\n") X (setq buffer-read-only t) X (message "Formatting units table...done")) X (setq math-units-table-buffer-valid t) X (let ((oldbuf (current-buffer))) X (set-buffer buf) X (goto-char (point-min)) X (set-buffer oldbuf)) X (if enter-buffer X (pop-to-buffer buf) X (display-buffer buf))) X (if enter-buffer X (pop-to-buffer (get-buffer "*Units Table*")) X (display-buffer (get-buffer "*Units Table*")))) ) X X X X SHAR_EOF echo 'File calc-units.el is complete' && chmod 0644 calc-units.el || echo 'restore of calc-units.el failed' Wc_c="`wc -c < 'calc-units.el'`" test 41220 -eq "$Wc_c" || echo 'calc-units.el: original size 41220, current size' "$Wc_c" rm -f _shar_wnt_.tmp fi # ============= calc-yank.el ============== if test -f 'calc-yank.el' -a X"$1" != X"-c"; then echo 'x - skipping calc-yank.el (File already exists)' rm -f _shar_wnt_.tmp else > _shar_wnt_.tmp echo 'x - extracting calc-yank.el (Text)' sed 's/^X//' << 'SHAR_EOF' > 'calc-yank.el' && ;; Calculator for GNU Emacs, part II [calc-yank.el] ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu. X ;; This file is part of GNU Emacs. X ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY. No author or distributor ;; accepts responsibility to anyone for the consequences of using it ;; or for whether it serves any particular purpose or works at all, ;; unless he says so in writing. Refer to the GNU Emacs General Public ;; License for full details. X ;; Everyone is granted permission to copy, modify and redistribute ;; GNU Emacs, but only under the conditions described in the ;; GNU Emacs General Public License. A copy of this license is ;; supposed to have been given to you along with GNU Emacs so you ;; can know your rights and responsibilities. It should be in a ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. X X X ;; This file is autoloaded from calc-ext.el. (require 'calc-ext) X (require 'calc-macs) X (defun calc-Need-calc-yank () nil) X X ;;; Kill ring commands. X (defun calc-kill (nn &optional no-delete) X (interactive "P") X (if (eq major-mode 'calc-mode) X (calc-wrapper X (calc-force-refresh) X (calc-set-command-flag 'no-align) X (let ((num (max (calc-locate-cursor-element (point)) 1)) X (n (prefix-numeric-value nn))) X (if (< n 0) X (progn X (if (eobp) X (setq num (1- num))) X (setq num (- num n) X n (- n)))) X (let ((stuff (calc-top-list n (- num n -1)))) X (calc-cursor-stack-index num) X (let ((first (point))) X (calc-cursor-stack-index (- num n)) X (if (null nn) X (backward-char 1)) ; don't include newline for raw C-k X (copy-region-as-kill first (point)) X (if (not no-delete) X (calc-pop-stack n (- num n -1)))) X (setq calc-last-kill (cons (car kill-ring) stuff))))) X (kill-line nn)) ) X (defun calc-force-refresh () X (if (or calc-executing-macro calc-display-dirty) X (let ((calc-executing-macro nil)) X (calc-refresh))) ) X (defun calc-locate-cursor-element (pt) X (save-excursion X (goto-char (point-max)) X (calc-locate-cursor-scan (- calc-stack-top) calc-stack pt)) ) X (defun calc-locate-cursor-scan (n stack pt) X (if (or (<= (point) pt) X (null stack)) X n X (forward-line (- (nth 1 (car stack)))) X (calc-locate-cursor-scan (1+ n) (cdr stack) pt)) ) X (defun calc-kill-region (top bot &optional no-delete) X (interactive "r") X (if (eq major-mode 'calc-mode) X (calc-wrapper X (calc-force-refresh) X (calc-set-command-flag 'no-align) X (let* ((top-num (calc-locate-cursor-element top)) X (bot-num (calc-locate-cursor-element (1- bot))) X (num (- top-num bot-num -1))) X (copy-region-as-kill top bot) X (setq calc-last-kill (cons (car kill-ring) X (calc-top-list num bot-num))) X (if (not no-delete) X (calc-pop-stack num bot-num)))) X (if no-delete X (copy-region-as-kill top bot) X (kill-region top bot))) ) X (defun calc-copy-as-kill (n) X (interactive "P") X (calc-kill n t) ) X (defun calc-copy-region-as-kill (top bot) X (interactive "r") X (calc-kill-region top bot t) ) X ;;; This function uses calc-last-kill if possible to get an exact result, ;;; otherwise it just parses the yanked string. (defun calc-yank () X (interactive) X (calc-wrapper X (calc-pop-push-record-list X 0 "yank" X (if (eq (car-safe calc-last-kill) (car kill-ring-yank-pointer)) X (cdr calc-last-kill) X (if (stringp (car kill-ring-yank-pointer)) X (let ((val (math-read-exprs X (calc-clean-newlines (car kill-ring-yank-pointer))))) X (if (eq (car-safe val) 'error) X (progn X (setq val (math-read-exprs (car kill-ring-yank-pointer))) X (if (eq (car-safe val) 'error) X (error "Bad format in yanked data") X val)) X val)))))) ) X (defun calc-clean-newlines (s) X (cond X X ;; Omit leading/trailing whitespace X ((or (string-match "\\`[ \n\r]+\$[^\001]*\$\\'" s) X (string-match "\\`\$[^\001]*\$[ \n\r]+\\'" s)) X (calc-clean-newlines (math-match-substring s 1))) X X ;; Convert newlines to commas X ((string-match "\\`\$.*\$[\n\r]+\$[^\001]*\$\\'" s) X (calc-clean-newlines (concat (math-match-substring s 1) "," X (math-match-substring s 2)))) X X (t s)) ) X X (defun calc-do-grab-region (top bot arg) X (and (memq major-mode '(calc-mode calc-trail-mode)) X (error "This command works only in a regular text buffer.")) X (let* ((from-buffer (current-buffer)) X (calc-was-started (get-buffer-window "*Calculator*")) X (single nil) X data vals pos) X (if arg X (if (consp arg) X (setq single t) X (setq arg (prefix-numeric-value arg)) X (if (= arg 0) X (save-excursion X (beginning-of-line) X (setq top (point)) X (end-of-line) X (setq bot (point))) X (save-excursion X (setq top (point)) X (forward-line arg) X (if (> arg 0) X (setq bot (point)) X (setq bot top X top (point))))))) X (setq data (buffer-substring top bot)) X (calc) X (if single X (setq vals (math-read-expr data)) X (setq vals (math-read-expr (concat "[" data "]"))) X (and (eq (car-safe vals) 'vec) X (= (length vals) 2) X (eq (car-safe (nth 1 vals)) 'vec) X (setq vals (nth 1 vals)))) X (if (eq (car-safe vals) 'error) X (progn X (if calc-was-started X (pop-to-buffer from-buffer) X (calc-quit t) X (switch-to-buffer from-buffer)) X (goto-char top) X (forward-char (+ (nth 1 vals) (if single 0 1))) X (error (nth 2 vals)))) X (calc-wrapper X (calc-enter-result 0 "grab" vals))) ) X X (defun calc-do-grab-rectangle (top bot arg) X (and (memq major-mode '(calc-mode calc-trail-mode)) X (error "This command works only in a regular text buffer.")) X (let* ((col1 (save-excursion (goto-char top) (current-column))) X (col2 (save-excursion (goto-char bot) (current-column))) X (from-buffer (current-buffer)) X (calc-was-started (get-buffer-window "*Calculator*")) X data mat vals lnum pt pos) X (if (= col1 col2) X (save-excursion X (or (= col1 0) X (error "Point and mark must be at beginning of line, or define a rectangle")) X (goto-char top) X (while (< (point) bot) X (setq pt (point)) X (forward-line 1) X (setq data (cons (buffer-substring pt (1- (point))) data))) X (setq data (nreverse data))) X (setq data (extract-rectangle top bot))) X (calc) X (setq mat (list 'vec) X lnum 0) X (and arg X (setq arg (if (consp arg) 0 (prefix-numeric-value arg)))) X (while data X (if (natnump arg) X (progn X (if (= arg 0) X (setq arg 1000000)) X (setq pos 0 X vals (list 'vec)) X (let ((w (length (car data))) X j v) X (while (< pos w) X (setq j (+ pos arg) X v (if (>= j w) X (math-read-expr (substring (car data) pos)) X (math-read-expr (substring (car data) pos j)))) X (if (eq (car-safe v) 'error) X (setq vals v w 0) X (setq vals (nconc vals (list v)) X pos j))))) X (if (and (null arg) X (string-match "[[{][^][{}]*[]}]" (car data))) X (setq pos (match-beginning 0) X vals (math-read-expr (math-match-substring (car data) 0))) X (let ((s (if (string-match X "\\`\$[0-9]+:[ \t]\$?\$.*[^, \t]\$[, \t]*\\'" X (car data)) X (math-match-substring (car data) 2) X (car data)))) X (setq pos -1 X vals (math-read-expr (concat "[" s "]"))) X (if (eq (car-safe vals) 'error) X (let ((v2 (math-read-expr s))) X (or (eq (car-safe v2) 'error) X (setq vals (list 'vec v2)))))))) X (if (eq (car-safe vals) 'error) X (progn X (if calc-was-started X (pop-to-buffer from-buffer) X (calc-quit t) X (switch-to-buffer from-buffer)) X (goto-char top) X (forward-line lnum) X (forward-char (+ (nth 1 vals) (min col1 col2) pos)) X (error (nth 2 vals)))) X (setq mat (cons vals mat) X data (cdr data) X lnum (1+ lnum))) X (calc-wrapper X (calc-enter-result 0 "grab" (nreverse mat)))) ) X X (defun calc-copy-to-buffer (nn) X "Copy the top of stack into an editing buffer." X (interactive "P") X (let ((thebuf (and (not (memq major-mode '(calc-mode calc-trail-mode))) X (current-buffer))) X (movept nil) X oldbuf newbuf) X (calc-wrapper X (save-excursion X (calc-force-refresh) X (let ((n (prefix-numeric-value nn)) X (eat-lnums calc-line-numbering) X top bot) X (setq oldbuf (current-buffer) X newbuf (or thebuf X (calc-find-writable-buffer (buffer-list) 0) X (calc-find-writable-buffer (buffer-list) 1) X (error "No other buffer"))) X (cond ((and (or (null nn) X (consp nn)) X (= (calc-substack-height 0) X (1- (calc-substack-height 1)))) X (calc-cursor-stack-index 1) X (if (looking-at X (if calc-line-numbering "[0-9]+: *[^ \n]" " *[^ \n]")) X (goto-char (1- (match-end 0)))) X (setq eat-lnums nil X top (point)) X (calc-cursor-stack-index 0) X (setq bot (1- (point)))) X ((> n 0) X (calc-cursor-stack-index n) X (setq top (point)) X (calc-cursor-stack-index 0) X (setq bot (- (point) X (if (eq calc-language 'big) 1 0)))) X ((< n 0) X (calc-cursor-stack-index (- n)) X (setq top (point)) X (calc-cursor-stack-index (1- (- n))) X (setq bot (point))) X (t X (goto-char (point-min)) X (forward-line 1) X (setq top (point)) X (calc-cursor-stack-index 0) X (setq bot (point)))) X (save-excursion X (set-buffer newbuf) X (if (consp nn) X (kill-region (region-beginning) (region-end))) X (push-mark (point) t) X (if (and overwrite-mode (not (consp nn))) X (calc-overwrite-string (save-excursion X (set-buffer oldbuf) X (buffer-substring top bot)) X eat-lnums) X (or (bolp) (setq eat-lnums nil)) X (insert-buffer-substring oldbuf top bot) X (and eat-lnums X (let ((n 1)) X (while (and (> (point) (mark)) X (progn X (forward-line -1) X (>= (point) (mark)))) X (delete-char 4) X (setq n (1+ n))) X (forward-line n)))) X (if thebuf (setq movept (point))) X (if (get-buffer-window (current-buffer)) X (set-window-point (get-buffer-window (current-buffer)) X (point))))))) X (if movept (goto-char movept)) X (and (consp nn) X (not thebuf) X (progn X (calc-quit t) X (switch-to-buffer newbuf)))) ) X (defun calc-overwrite-string (str eat-lnums) X (if (string-match "\n\\'" str) X (setq str (substring str 0 -1))) X (if eat-lnums X (setq str (substring str 4))) X (if (and (string-match "\\`[-+]?[0-9.]+\$e-?[0-9]+\$?\\'" str) X (looking-at "[-+]?[0-9.]+\$e-?[0-9]+\$?")) X (progn X (delete-region (point) (match-end 0)) X (insert str)) X (let ((i 0)) X (while (< i (length str)) X (if (= (setq last-command-char (aref str i)) ?\n) X (or (= i (1- (length str))) X (let ((pt (point))) X (end-of-line) X (delete-region pt (point)) X (if (eobp) X (insert "\n") X (forward-char 1)) X (if eat-lnums (setq i (+ i 4))))) X (self-insert-command 1)) X (setq i (1+ i))))) ) X ;;; First, require that buffer is visible and does not begin with "*" ;;; Second, require only that it not begin with "*Calc" (defun calc-find-writable-buffer (buf mode) X (and buf X (if (or (string-match "\\`\$ .*\\|\\*Calc.*\$" X (buffer-name (car buf))) X (and (= mode 0) X (or (string-match "\\`\\*.*" (buffer-name (car buf))) X (not (get-buffer-window (car buf)))))) X (calc-find-writable-buffer (cdr buf) mode) X (car buf))) ) X X (defun calc-edit (n) X (interactive "p") X (calc-slow-wrapper X (if (eq n 0) X (setq n (calc-stack-size))) X (let* ((flag nil) X (allow-ret (> n 1)) X (list (math-showing-full-precision X (mapcar (if (> n 1) X (function (lambda (x) X (math-format-flat-expr x 0))) X (function X (lambda (x) X (if (math-vectorp x) (setq allow-ret t)) X (math-format-nice-expr x (screen-width))))) X (if (> n 0) X (calc-top-list n) X (calc-top-list 1 (- n))))))) X (calc-edit-mode (list 'calc-finish-stack-edit (or flag n)) allow-ret) X (while list X (insert (car list) "\n") X (setq list (cdr list))))) X (calc-show-edit-buffer) ) X (defun calc-alg-edit (str) X (calc-edit-mode '(calc-finish-stack-edit 0)) X (calc-show-edit-buffer) X (insert str "\n") X (backward-char 1) X (calc-set-command-flag 'do-edit) ) X (defvar calc-edit-mode-map nil "Keymap for use by the calc-edit command.") (if calc-edit-mode-map X () X (setq calc-edit-mode-map (make-sparse-keymap)) X (define-key calc-edit-mode-map "\n" 'calc-edit-finish) X (define-key calc-edit-mode-map "\r" 'calc-edit-return) X (define-key calc-edit-mode-map "\C-c\C-c" 'calc-edit-finish) ) X (defun calc-edit-mode (&optional handler allow-ret title) X "Calculator editing mode. Press RET, LFD, or C-c C-c to finish. To cancel the edit, simply kill the *Calc Edit* buffer." X (interactive) X (or handler X (error "This command can be used only indirectly through calc-edit.")) X (let ((oldbuf (current-buffer)) X (buf (get-buffer-create "*Calc Edit*"))) X (set-buffer buf) X (kill-all-local-variables) X (use-local-map calc-edit-mode-map) X (setq buffer-read-only nil) X (setq truncate-lines nil) X (setq major-mode 'calc-edit-mode) X (setq mode-name "Calc Edit") X (run-hooks 'calc-edit-mode-hook) X (make-local-variable 'calc-original-buffer) X (setq calc-original-buffer oldbuf) X (make-local-variable 'calc-return-buffer) X (setq calc-return-buffer oldbuf) X (make-local-variable 'calc-one-window) X (setq calc-one-window (and (one-window-p t) pop-up-windows)) X (make-local-variable 'calc-edit-handler) SHAR_EOF true || echo 'restore of calc-yank.el failed' fi echo 'End of part 29' echo 'File calc-yank.el is continued in part 30' echo 30 > _shar_seq_.tmp exit 0 exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.